home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 February: Tool Chest / Apple Developer CD Series Tool Chest February 1996 (Apple Computer)(1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / 2.01 sources / Library-2.01 / pop-up-menu.lisp < prev    next >
Encoding:
Text File  |  1993-09-16  |  14.3 KB  |  351 lines  |  [TEXT/CCL2]
  1. ;;-*- Mode: Lisp; Package: CCL -*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;  pop-up-menu.lisp
  4. ;;
  5. ;;
  6. ;;  ©1989, Apple Computer, Inc
  7. ;;
  8. ;;  this file implements pop-up menus, according to the Apple standard.
  9. ;;  it also shows how multiple-inheritance can be handy!
  10. ;;
  11.  
  12.  
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ;;
  15. ;; Mod History
  16. ;;
  17. ;; 04/28/93 mwp Release
  18. ;; 11/11/92 bill  Straz'es patch to specify background color with :menu-body.
  19. ;;--------------  2.0
  20. ;; 03/23/92 bill  set-view-size needed to force an erase.
  21. ;;                menu-select now works correctly for hierarchical pop-up menus
  22. ;;                (which are not Human Interface Guidelines compliant).
  23. ;; -------------  2.0f3
  24. ;; 10/18/91 bill  optimize view-draw-contents a little.
  25. ;;                Adjust position of pop up menu
  26. ;; 10/15/91 bill  window-font -> view-font
  27. ;;                Add the little System 7 triangle.
  28. ;;--------------  2.0b3
  29. ;; 06/21/91 bill  wkf's mod: Add foreground color for titles of pop up menus.
  30. ;;--------------  2.0b2
  31.  
  32. ;;;;;;;;;;;;;;;;;;
  33. ;;
  34. ;;  packages, proclamations, and requires
  35. ;;
  36.  
  37. (in-package :ccl)
  38.  
  39. (eval-when (:compile-toplevel :load-toplevel :execute)
  40.   (export '(pop-up-menu selected-item) :ccl))
  41.  
  42. (defclass pop-up-menu (menu dialog-item)
  43.   ((width-correction :allocation :class :initform 0
  44.                      :accessor pop-up-menu-width-correction)
  45.    (menu-rect :initform nil :accessor pop-up-menu-rect)
  46.    (title-rect :initform nil :accessor pop-up-menu-title-rect)
  47.    (default-item :initarg :default-item :initform 1
  48.                  :accessor pop-up-menu-default-item)
  49.    (auto-update-default :initarg :auto-update-default :initform t
  50.                         :accessor pop-up-menu-auto-update-default)
  51.    (item-display :initarg :item-display :initform :selection
  52.                  :accessor pop-up-menu-item-display))
  53.   (:default-initargs 
  54.     :menu-title "Untitled"
  55.     :view-font '("Chicago" 12 :plain)))
  56.  
  57.  
  58. ;;;;;;;;;;;;;;
  59. ;;
  60. ;; width-correction will be set each time a menu is installed.
  61. ;; the actual amount depends on the text of the menu-items
  62. ;; the instance sets width-correction to the correct value, and then
  63. ;; calls the usual size-defaulting function
  64. ;;
  65. ;;;;;;;;;;;;;;
  66.  
  67.  
  68. ;;;;;;;;;;;;;;;;;;;;
  69. ;;
  70. ;;  definitions for pop-up menus
  71. ;;
  72.  
  73.  
  74. (defmethod menu-title ((menu pop-up-menu))
  75.   (dialog-item-text menu))
  76.  
  77. (defmethod set-menu-title ((menu pop-up-menu) new-title)
  78.   (set-dialog-item-text menu new-title))
  79.  
  80. (defmethod install-view-in-window ((menu pop-up-menu) view)
  81.   (declare (ignore view))
  82.   (menu-install menu)
  83.   (call-next-method)
  84.   (size-rectangles menu)
  85.   (invalidate-view menu))
  86.  
  87. (defmethod set-view-size :after ((menu pop-up-menu) h &optional v)
  88.   (declare (ignore h v))
  89.   (size-rectangles menu)
  90.   (invalidate-view menu t))
  91.  
  92. (defmethod set-view-position :after ((menu pop-up-menu) h &optional v)
  93.   (declare (ignore h v))
  94.   (size-rectangles menu))
  95.  
  96. (defmethod size-rectangles ((menu pop-up-menu))
  97.   "does a lot of tweaking to get the thing to draw right"
  98.   (let* ((my-pos (view-position menu))
  99.          (my-size (add-points (view-size menu) #@(-1 -1)))
  100.          (text (dialog-item-text menu))
  101.          (title-offset (make-point (if (eql 0 (length text))
  102.                                      0
  103.                                      (+ 8 (string-width
  104.                                            text
  105.                                            (or (view-font menu)
  106.                                                (view-font (view-window menu))))))
  107.                                    0))
  108.          (menu-rect (or (pop-up-menu-rect menu)
  109.                         (setf (pop-up-menu-rect menu) (make-record :rect))))
  110.          (title-rect (or (pop-up-menu-title-rect menu)
  111.                          (setf (pop-up-menu-title-rect menu)
  112.                                (make-record :rect)))))
  113.     (rset menu-rect :rect.topleft (add-points my-pos title-offset))
  114.     (rset menu-rect :rect.bottomright (add-points my-pos my-size))
  115.     (rset title-rect :rect.topleft my-pos)
  116.     (rset title-rect :rect.bottomright (make-point (+ (point-h my-pos)
  117.                                                       title-offset)
  118.                                                    (+ (point-v my-pos)
  119.                                                       (point-v my-size)
  120.                                                       -4)))))
  121.  
  122. (defmethod remove-view-from-window ((menu pop-up-menu))
  123.   (menu-deinstall menu)
  124.   (call-next-method)
  125.   (without-interrupts
  126.    (dispose-record (pop-up-menu-rect menu) :rect)
  127.    (setf (pop-up-menu-rect menu) nil)
  128.    (dispose-record (pop-up-menu-title-rect menu) :rect)
  129.    (setf (pop-up-menu-title-rect menu) nil)))
  130.  
  131. (defmethod view-draw-contents ((menu pop-up-menu) &aux (items (menu-items menu)))
  132.   (let* ((pos (view-position menu))
  133.          (text (dialog-item-text menu))
  134.          (ti-rect (pop-up-menu-title-rect menu))
  135.          (item-display (pop-up-menu-item-display menu)))
  136.     (rlet ((a-rect :rect))
  137.       (copy-record (pop-up-menu-rect menu) :rect a-rect)
  138.       (with-pstrs ((mi-title (if (eq item-display :selection)
  139.                                (if items
  140.                                  (menu-item-title
  141.                                   (nth (- (pop-up-menu-default-item menu) 1)
  142.                                        items))
  143.                                  "<No Items>")
  144.                                (if (stringp item-display)
  145.                                  item-display
  146.                                  (format nil "~a" item-display)))))
  147.         (with-fore-color (part-color menu :menu-title) ; 21-Jun-91 -wkf
  148.           (with-back-color (part-color menu :menu-body) ; 10-Nov-92 -straz
  149.             (unless (equal text "")
  150.               (#_EraseRect :ptr ti-rect)
  151.               (#_MoveTo :word (+ (point-h pos) 3)
  152.                :word (- (rref a-rect rect.bottom) 8))
  153.               (with-pstrs ((di-title text))
  154.                 (#_DrawString :ptr di-title)))
  155.             ;  (#_OffsetRect :ptr a-rect :long #@(0 -1))
  156.             (#_FrameRect :ptr a-rect)
  157.             (#_MoveTo :word (+ (rref a-rect rect.left) 3)
  158.              :word (rref a-rect rect.bottom))
  159.             (#_LineTo :word (rref a-rect rect.right)
  160.              :word (rref a-rect rect.bottom))
  161.             (#_LineTo :word (rref a-rect rect.right)
  162.              :word (rref a-rect rect.top))
  163.             (#_InsetRect :ptr a-rect :long #@(1 1))
  164.             (#_FillRect :ptr a-rect :ptr *white-pattern*)
  165.             (#_MoveTo :word (+ (rref a-rect rect.left) 3)
  166.              :word (- (rref a-rect rect.bottom) 5))
  167.             (with-clip-rect a-rect
  168.               (#_DrawString :ptr mi-title)
  169.               (#_MoveTo :word (- (rref a-rect :rect.right) (+ 4 11))
  170.                :word (- (ash (+ (rref a-rect :rect.bottom) (rref a-rect :rect.top)) -1)
  171.                         2))
  172.               ; Draw the little triangle.
  173.               (#_line :long #@(10 0))
  174.               (#_line :long #@(-5 5))
  175.               (#_line :long #@(-4 -4))
  176.               (#_line :long #@(7 0))
  177.               (#_line :long #@(-3 3))
  178.               (#_line :long #@(-2 -2))
  179.               (#_line :long #@(3 0))
  180.               (#_line :long #@(-1 1)))))))
  181.     (unless (dialog-item-enabled-p menu)
  182.       (rlet ((ps :penstate))
  183.         (with-item-rect (rect menu)
  184.           (#_InsetRect :ptr rect :long #@(0 -1))
  185.           (#_GetPenState :ptr ps)
  186.           (#_PenPat :ptr *gray-pattern*)
  187.           (#_PenMode :word 11)
  188.           (#_PaintRect :ptr rect)
  189.           (#_SetPenState :ptr ps))))))
  190.  
  191. ;;;;;;;;;;;
  192. ;;
  193. ;;  the usual dialog-item-default-size calculates the width from the
  194. ;;  width-correction instance-variable, and the width of the dialog-item-text.
  195. ;;  before calling the usual, we set width-correction to take into account
  196. ;;  the width of the menu-items
  197. ;;
  198. ;;  The usual version calculates the height from the font-height.  We need
  199. ;;  to increase this by four, to allow for a border.
  200. ;;
  201.  
  202. (defmethod view-default-size ((menu pop-up-menu))
  203.   (let* ((the-font (view-font menu))
  204.          (item-display (slot-value menu 'item-display))
  205.          (max-menu-width (max 20 (if (stringp item-display)
  206.                                    (string-width
  207.                                     (or item-display "")
  208.                                     the-font)
  209.                                    0))))
  210.     (setf (dialog-item-width-correction menu)
  211.           (+ (if (equal "" (dialog-item-text menu)) 9 18)
  212.              (dolist (m (menu-items menu) max-menu-width)
  213.                (when (> (setq m (string-width (menu-item-title m)
  214.                                               the-font))
  215.                         max-menu-width)
  216.                  (setq max-menu-width m)))))
  217.     (add-points #@(19 4)
  218.                 (call-next-method))))
  219.  
  220. (defmethod view-click-event-handler ((menu pop-up-menu) where)
  221.   (declare (ignore where))
  222.   (let ((no-text (equal (dialog-item-text menu) "")))
  223.     (unless no-text
  224.       (#_InvertRect :ptr (pop-up-menu-title-rect menu)))
  225.     (menu-select menu 0)
  226.     (if (eq (pop-up-menu-item-display menu) :selection)
  227.       (view-draw-contents menu)
  228.       (unless no-text
  229.         (#_InvertRect :ptr (pop-up-menu-title-rect menu))))))
  230.  
  231. ;Update the menu's items then displays the pop-menu.  Default-item is the
  232. ;item which will come up selected  when the menu is displayed.
  233. (defmethod menu-select ((menu pop-up-menu) num
  234.                         &aux selection
  235.                         selected-menu
  236.                         selected-menu-item
  237.                         (a-rect (pop-up-menu-rect menu))
  238.                         (pos (with-focused-view (view-container menu)
  239.                                (%local-to-global 
  240.                                 (wptr menu)
  241.                                 (rref a-rect :rect.topleft)))))
  242.   (declare (ignore num))
  243.   (menu-update menu)
  244.   (setq selection (#_PopUpMenuSelect
  245.                    :ptr (slot-value menu 'menu-handle)
  246.                    :word (+ (point-v pos) 1)
  247.                    :word (+ (point-h pos) 1)
  248.                    :word (or (pop-up-menu-default-item menu) 0)
  249.                    :long)
  250.         ;we get the selected menu in case you want to break the rules
  251.         ;and use heirarchical menus in a pop-up menu
  252.         selected-menu (menu-object (ash (logand #xFFFF0000 selection) -16))
  253.         selected-menu-item (logand #x0000FFFF selection))
  254.   (unless (eq selected-menu-item 0)
  255.     (when (pop-up-menu-auto-update-default menu)
  256.       (setf (pop-up-menu-default-item menu)
  257.             (if (eq selected-menu menu)
  258.               selected-menu-item
  259.               (let ((1st-level-submenu selected-menu))
  260.                 (loop
  261.                   (let ((owner (menu-owner 1st-level-submenu)))
  262.                     (if (eq owner menu)
  263.                       (return (1+ (position 1st-level-submenu (menu-items menu)))))
  264.                     (if (null owner)
  265.                       (return (pop-up-menu-default-item menu)))
  266.                     (setq 1st-level-submenu owner)))))))
  267.     (menu-item-action
  268.      (nth (- selected-menu-item 1) (menu-items selected-menu)))))
  269.  
  270. (defmethod menu-install ((menu pop-up-menu))
  271.   "Creates the actual Macintosh menu with all of the menu's current items."
  272.   (let* ((menu-items (menu-items menu)))
  273.     (apply #'remove-menu-items menu menu-items)
  274.     (init-menu-id menu)
  275.     (with-pstrs ((menu-title (menu-title menu)))
  276.       (let ((menu-handle (#_NewMenu :word (slot-value menu 'menu-id)
  277.                                    :ptr menu-title
  278.                                    :ptr)))
  279.         (#_InsertMenu :ptr menu-handle
  280.                      :word -1)
  281.         (setf (slot-value menu 'menu-handle) menu-handle)))
  282.     (let* ((colors (part-color-list menu)))
  283.       (loop
  284.         (unless colors (return))
  285.         (set-part-color menu (pop colors) (pop colors))))
  286.     (apply #'add-menu-items menu menu-items)))
  287.  
  288. (defmethod menu-deinstall ((menu pop-up-menu))
  289.   (let* ((*menubar-frozen* t))
  290.     (call-next-method)))
  291.  
  292. (defmethod selected-item ((menu pop-up-menu))
  293.   (nth (- (pop-up-menu-default-item menu) 1) (menu-items menu)))
  294.  
  295.  
  296. (provide 'pop-up-menu)
  297.  
  298. #|
  299. (setq my-pop-up
  300.       (make-instance 'pop-up-menu
  301.                      :dialog-item-text "Wowie"
  302.                      :menu-items
  303.                      (list
  304.                       (make-instance 'menu-item
  305.                                      :menu-item-title "item one"
  306.                                      :menu-item-action #'(lambda ()
  307.                                                            (print 1)))
  308.                       (make-instance 'menu-item
  309.                                      :menu-item-title "item two"
  310.                                      :menu-item-action #'(lambda ()
  311.                                                            (print 2)))
  312.                       (make-instance 'menu-item
  313.                                      :menu-item-title "item three"
  314.                                      :menu-item-action #'(lambda ()
  315.                                                            (print 3)))
  316.                       (make-instance 'menu-item
  317.                                      :menu-item-title "item fourteen"
  318.                                      :menu-item-action #'(lambda ()
  319.                                                            (print 14))))))
  320.  
  321. (setq my-pop-up-2
  322.       (make-instance 'pop-up-menu
  323.                      :item-display "Wowie"
  324.                      :menu-items
  325.                      (list
  326.                       (make-instance 'menu-item
  327.                                      :menu-item-title "item one"
  328.                                      :menu-item-action #'(lambda ()
  329.                                                            (print 1)))
  330.                       (make-instance 'menu-item
  331.                                      :menu-item-title "item two"
  332.                                      :menu-item-action #'(lambda ()
  333.                                                            (print 2)))
  334.                       (make-instance 'menu-item
  335.                                      :menu-item-title "item three"
  336.                                      :menu-item-action #'(lambda ()
  337.                                                            (print 3)))
  338.                       (make-instance 'menu-item
  339.                                      :menu-item-title "item fourteen"
  340.                                      :menu-item-action #'(lambda ()
  341.                                                            (print 14))))))
  342.  
  343.  
  344. (setq my-dial (make-instance 'dialog
  345.                              :view-size #@(180 60)
  346.                              :window-title "Pop-up Menu Test"
  347.                              :view-subviews (list my-pop-up my-pop-up-2)))
  348.  
  349.  
  350. |#
  351.